home *** CD-ROM | disk | FTP | other *** search
/ Mac Power 1997 January / macpower199701.bin / AMUG / Publishing_19 / Alpha 6.5.sit / Tcl / Modes / fortranMode.tcl < prev    next >
Encoding:
Text File  |  1996-08-15  |  20.3 KB  |  670 lines  |  [TEXT/ALFA]
  1. #=============================================================================
  2. # Fortran mode definition and support procs
  3. #
  4. # Features:
  5. # 1.  Keyword colorization (slightly customizable)
  6. # 2.  Fortran-sensitive shift right/left preserve columns 1-6
  7. # 3.  Auto-indentation
  8. # 4.  Line-breaking with Ctl-Opt-J (a la emacs)
  9. # 5.  Subroutine indexing
  10. # 6.  Cmd-double-click subroutine and include-file lookup
  11. # 7.  Customizable comment and continuation characters
  12. #
  13. #------------------------------------------------------------------------------
  14. # Author: Tom Pollard <pollard@chem.columbia.edu>
  15. #
  16. # To Do:  work around grep failure for Unix-format tag files
  17. #
  18. #  1/96 - FortMarkFile no longer marks F90 "end subroutine ..." statements
  19. #         more F90 keywords (will they never cease?)
  20. #  1/96 - user-selectable comment and continuation characters
  21. #         complete F90 keyword set (Thomas Bewley <bewley@rayleigh.stanford.edu>) 
  22. #         F90 functions and comparison operators optionally colorized ( " " )
  23. #         more complete set of C preprocessor commands colorized
  24. #         fixed case-sensitivity problem in line-indent routines
  25. #  1/96 - minor FortDblClick bug fix
  26. # 12/95 - more complete keyword set for F90 and HPF (from Tom Scavo)
  27. # 12/95 - cpp keyword colorization (George Nurser <g.nurser@soc.soton.ac.uk>)
  28. #         cmd-dbl-click supports cpp #include now
  29. # 11/95 - added FortBreakLine
  30. #         fixed case-sensitivity bug
  31. # 10/95 - fixed Cmd-Dbl-Click handler to deal w/ new(?) tag file format and
  32. #            improve performance (fortFindSub)
  33. #  9/95 - fixed getFortPrev bug with numbered lines
  34. #       - shiftLeft/Right revert to normal behavior on ill-formatted lines
  35. #  8/95 - auto-indentation is finally speedy and robust
  36. #  5/95 - added Cmd-Dbl-Click handler
  37. #       - added auto-indentation
  38. # 12/94 - fixed funcExpr, FortMarkFile search expressions
  39. #       - changed comment character from 'C' to 'c' (should be case-insensitive!)
  40. #       - added 'include' keyword
  41. #       - added FortShiftRight and FortShiftLeft procs
  42. #------------------------------------------------------------------------------
  43.  
  44.  
  45. #================================================================================
  46. if {$startingUp} {
  47.     addMode Fort dummyFort {*.f *.inc *.INC *.fcm *.for *.FOR *.f9 *.f90 *.hpf } {}
  48.     return
  49. }
  50.  
  51.  
  52.  
  53. proc dummyFort {} {}
  54.  
  55. newModeVar Fort sortedIsDefault    {0} 1
  56. newModeVar Fort wordWrap        {0}    1
  57. newModeVar Fort funcExpr    {^[^cC*!][ ¥t]*(subroutine|[ ¥ta-z*0-9]*function|entry).*$} 0
  58. newModeVar Fort autoMark        {0}    1
  59. newModeVar Fort electricTab        {1}    1
  60.  
  61. # newModeVar Fort    prefixString    {c}    0
  62. newModeVar Fort    continueChar    {$}    0
  63. newModeVar Fort    commentChar    {c}    0
  64. newModeVar Fort    colorFuncs    {0}    1
  65. newModeVar Fort    colorOpers    {0}    1
  66.  
  67. newModeVar Fort indentComment    {0}    1
  68. newModeVar Fort markTag            {{}} 0
  69.  
  70. #=============================================================================
  71. # Colorize Fortran keywords
  72. #
  73. proc fortColorKeywords {{color blue} {comment red} {specialChars black}} {
  74.     global FortmodeVars
  75.  
  76.     set FortKeywords { 
  77.         allocatable allocate assign backspace block call character close common 
  78.         complex contains continue cycle data deallocate dimension do double else 
  79.         elseif end enddo endfile endif entry equivalence exit external extrinsic 
  80.         forall format function goto if implicit include inquire integer intent 
  81.         interface intrinsic logical module namelist nullify open optional 
  82.         parameter pause pointer precision print private program public pure read 
  83.         real recursive return rewind save sequence stop subroutine target then 
  84.         use where while write assignment case default elsewhere endfile go none 
  85.         operator procedure select to type
  86.     }
  87.     
  88.     if {$specialChars != "black"} {
  89.         regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords  -i {=}  -i {*}  -i {/}  -i {+}  -i {-}  -i {,}  -i {(} -i {)} -I $specialChars
  90.     } else {
  91.         regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords  
  92.     }
  93.     unset FortKeywords
  94. } 
  95.  
  96. #=============================================================================
  97. # Colorize selected C preprocessor keywords
  98. #
  99. proc fortColorCPP {{color green}} {
  100.     set CPPKeywords  {
  101.         #if #endif #include #else #define #undef #ifdef #ifndef
  102.     }
  103.     regModeKeywords -a  -k $color Fort $CPPKeywords
  104.     unset CPPKeywords
  105. }
  106.  
  107.  
  108. #=========================================================================
  109. # Colorize Fortran operators
  110. #
  111. proc fortColorOpers {{color green}} {
  112.     set FortOperators {
  113.         eq ne lt le gt ge not and or eqv neqv true false
  114.     }
  115.     regModeKeywords -a -k $color Fort $FortOperators
  116.     unset FortOperators
  117. }
  118.  
  119. #=========================================================================
  120. # Colorize Fortran function keywords
  121. #
  122. proc fortColorFuncs {{color green}} {
  123.     # Fortran bit functions
  124.     #
  125.     set BitKeywords {
  126.         bit_size btest iand ibclr ibits ibset ieor ior ishft ishftc mvbits not
  127.     }
  128.     regModeKeywords -a -k $color Fort $BitKeywords
  129.     unset BitKeywords
  130.     
  131.     # Fortran intrinsic functions
  132.     #
  133.     set IntrinsicKeywords {
  134.         abs acos aimag asin atan atan2 conjg cos cosh dble dim dprod exp ichar 
  135.         len lge lgt lle llt log log10 max min mod sign sin sinh sqrt tan tanh 
  136.         iabs dabs cabs dacos dint dnint dasin datan datan2 dcos ccos dcosh idim 
  137.         ddim dexp cexp ifix idint alog ddlog clog alog10 dlog10 max0 amax0 max1 
  138.         amax1 dmax1 min0 amin0 min1 amin1 dmin1 amod dmod idnint float sngl 
  139.         isign dsign dsin csin dsinh dsqrt csqrt dtan dtanh aint anint char cmplx 
  140.         index int nint achar adjustl adjustr all allocated any associated 
  141.         bit_size btest ceiling count cshift date_and_time digits dot_product 
  142.         eoshift epsilon exponent floor fraction huge iachar iand ibclr ibits 
  143.         ibset ieor ior ishft ishftc kind lbound len_trim logical matmul 
  144.         maxexponent maxloc maxval merge minexponent minloc minval modulo mvbits 
  145.         nearest not pack precision present product radix random_number 
  146.         random_seed range repeat reshape rrspacing scale scan selected_int_kind 
  147.         selected_real_kind set_exponent shape size spacing spread sum 
  148.         system_clock tiny transfer transpose trim ubound unpack verify
  149.     }
  150.     regModeKeywords -a -k $color Fort $IntrinsicKeywords
  151.     unset IntrinsicKeywords    
  152. }
  153.  
  154. fortColorKeywords blue red magenta
  155. fortColorCPP green
  156.  
  157. #=============================================================================
  158. # Special Fortran keybindings
  159. #
  160. bind '¥[' <c>  FortShiftLeft Fort
  161. bind '¥[' <co> FortShiftLeftSpace Fort
  162. bind '¥]' <c>  FortShiftRight Fort
  163. bind '¥]' <co> FortShiftRightSpace Fort
  164.  
  165. bind '¥t'       doATab Fort
  166. bind '¥t' <o>     {doATab 1} Fort
  167. bind '¥t' <z>     {doATab 1} Fort
  168.  
  169. bind 'j'  <zo> FortBreakLine Fort
  170.  
  171. trace variable FortmodeVars(commentChar) w shadowFort
  172. trace variable FortmodeVars(colorFuncs) w shadowFort
  173. trace variable FortmodeVars(colorOpers) w shadowFort
  174.  
  175. #=============================================================================
  176. # Update colorization when Fortran mode variables are changed
  177. #
  178. proc shadowFort {name1 name2 op} {
  179.     global HOME FortmodeVars
  180.     if {$name1 == "FortmodeVars" && $op == "w"} {
  181.         switch $name2 {
  182.             "colorFuncs"    {
  183.                 if {$FortmodeVars(colorFuncs)} {
  184.                     fortColorFuncs green
  185.                 } else {
  186.                     fortColorFuncs black
  187.                 }
  188.              }
  189.             "colorOpers"    {
  190.                 if {$FortmodeVars(colorOpers)} {
  191.                     fortColorOpers green
  192.                 } else {
  193.                     fortColorOpers black
  194.                 }
  195.              }
  196.             "commentChar" {    
  197.                 fortColorKeywords blue red black
  198.             }
  199.             default {
  200.                 return
  201.             }
  202.         }
  203.     }
  204. }
  205.  
  206. #=============================================================================
  207. #
  208. proc FortMarkFile {} {
  209.     global FortmodeVars
  210.     set tag [quoteExpr2 $FortmodeVars(markTag)]
  211.     
  212.     set pat0 {^.*(subroutine|.*function|entry|program).*$}
  213.     set pat1 {^[^cC*!]([ ¥ta-z*0-9]*)(subroutine|.*function|entry|program)[ ¥t]+([a-z0-9_]+)}
  214.     set end [maxPos]
  215.     set pos 0
  216.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat1 $pos} mtch]} {
  217.         regexp -nocase $pat1 [eval getText $mtch] allofit valtyp subtyp name
  218.         set start [lineStart [lindex $mtch 0]]
  219.         set next [nextLineStart $start]
  220.         set pos $next
  221.         if {! [regexp -nocase "end" $valtyp mtch]} {
  222.             set inds([lineStart $start]) $name
  223.         }
  224.         
  225.     }
  226.     
  227.     set pat2 "^(c+${tag})¥[ ¥t¥]*(¥[^¥n¥r¥]*¥[^ ¥t¥])¥[^ ¥t¥]*¥$"
  228.     set pos 0
  229.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat2 $pos} mtch]} {
  230.         regexp -nocase $pat2 [eval getText $mtch] allofit cc comment
  231.         regsub -all {[¥/¥(¥)]} $comment {} comment
  232.         set start [lindex $mtch 0]
  233.         set end [nextLineStart $start]
  234.         set pos $end
  235.         set inds([lineStart $start]) $comment
  236.     }
  237.     
  238.     if {[info exists inds]} {
  239.         foreach f [lsort -integer [array names inds]] {
  240.             set next [nextLineStart $f ]
  241.             setNamedMark $inds($f) $f $f $f
  242.         }
  243.     }
  244. }
  245.  
  246. #================================================================================
  247. # Block shift left and right for Fortran mode (preserves cols 1-6)
  248. #================================================================================
  249.  
  250. proc FortShiftLeft {} {
  251.     global shiftChar
  252.     doFortShiftLeft "¥t"
  253.     
  254. }
  255. proc FortShiftLeftSpace {} {
  256.     global shiftChar
  257.     doFortShiftLeft " "
  258. }
  259.  
  260. proc doFortShiftLeft {shiftChar} {
  261.     set start [lineStart [getPos]]
  262.     set end [nextLineStart [expr [selEnd] - 1]]
  263.     if {$start >= $end} {set end [nextLineStart $start]}
  264.     
  265.     set text [split [getText $start [expr $end - 1]] "¥r"]
  266.     
  267.     set textout ""
  268.     
  269.     set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*¥t)(.*)$}
  270.     foreach line $text {
  271.         if {[regexp $pat $line mtch pref body]} {
  272.             if {[string index $body 0] == $shiftChar} {
  273.                 lappend textout $pref[string range $body 1 end]
  274.             } else {
  275.                 lappend textout $line
  276.             }
  277.  
  278.         } elseif {[string index $line 0] == $shiftChar} {
  279.             lappend textout [string range $line 1 end]
  280.  
  281.         } else {
  282.             lappend textout $line
  283.         }
  284.     }
  285.  
  286.     set text [join $textout "¥r"]    
  287.     replaceText $start [expr $end - 1] $text
  288.     select $start [expr 1 + $start + [string length $text]]
  289. }
  290.  
  291. proc FortShiftRight {} {
  292.     global shiftChar
  293.     doFortShiftRight "¥t"
  294.     
  295. }
  296. proc FortShiftRightSpace {} {
  297.     global shiftChar
  298.     doFortShiftRight " "
  299. }
  300.  
  301. proc doFortShiftRight {shiftChar} {
  302.     set start [lineStart [getPos]]
  303.     set end [nextLineStart [expr [selEnd] - 1]]
  304.     if {$start >= $end} {set end [nextLineStart $start]}
  305.     
  306.     set text [split [getText $start [expr $end - 1]] "¥r"]
  307.     
  308.     set textout ""
  309.     
  310.     set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*¥t)(.*)$}
  311.     foreach line $text {
  312.         if {[regexp $pat $line mtch pref body]} {
  313.             lappend textout $pref$shiftChar$body
  314.         } else {
  315.             lappend textout $shiftChar$line
  316.         }
  317.     }
  318.     
  319.     set text [join $textout "¥r"]    
  320.     replaceText $start [expr $end - 1] $text
  321.     select $start [expr 1 + $start + [string length $text]]
  322. }
  323.  
  324. proc FortBreakLine {} {
  325.     global FortmodeVars
  326.     set pos [getPos]
  327.     set line [getText [lineStart $pos] [expr [nextLineStart $pos]-1]]
  328.     if {[regexp {^[cC*!]} $line char]} {
  329.         insertText "¥n$char "
  330.     } else {
  331.         set char $FortmodeVars(continueChar)
  332.         insertText "¥n     $char"
  333.     }
  334.     FortindentLine
  335. }
  336.  
  337. #=============================================================================
  338. # Cmd-double-clicking opens include files, jumps to subroutine definitions,
  339. # and follows tags.
  340. #
  341. proc FortDblClick {from to} {
  342.     global tagFile
  343.     set pat1 {^[^cC*!][ ¥ta-z*0-9]*(subroutine|.*function|entry)[ ¥t]+}
  344.     set incPat {^[^cC*!][ ¥t]*include[ ¥t]*['"]([^'"]+)['"]}
  345.  
  346.     # First check whether an 'include' was clicked
  347.     set line [getText [lineStart $from] [expr [nextLineStart $to] - 1]]
  348.     if {[regexp -nocase $incPat $line allofit fname]} {
  349.         set path [absolutePath $fname]
  350.         if {[catch {openFileQuietly $path}]} { 
  351.             message "include file ¥'$fname¥' not found in source folder"
  352.         }
  353.         return
  354.     }
  355.     
  356.     select $from $to
  357.     set text [getSelect]
  358.     
  359.     # First check current file for subroutine definition,...
  360.     if {![catch {fortFindSub $text} mtch]} { 
  361.         regexp -nocase $pat1 [eval getText $mtch] allofit subtyp name
  362.         pushMark
  363.         display [lindex $mtch 0]
  364. #         eval select $mtch
  365.         message "press <Ctl .> to return to original cursor position"
  366.  
  367.     # ...then check tags file.
  368.     } else {
  369.         message "Searching tags file..."
  370.         set lines [grep "^$text'" $tagFile]
  371.         if {[regexp {'(.*)'} $lines dummy fname]} { 
  372.             pushMark
  373.             if {[string match "*$fname*" [winNames -f]]} {
  374.                 bringToFront $fname
  375.             } else {
  376.                 edit $fname
  377.             }
  378.             set inds [fortFindSub $text]
  379. #             set inds [search -s -f 1 -r 1 -i 1 "$pat1$text" 0]
  380.             display [lindex $inds 0]
  381. #             eval select $inds
  382.             message "press <Ctl .> to return to original cursor position"
  383.         }
  384.     }
  385. }
  386.  
  387. # Speedy search for a Fortran subroutine.  Performance is dramatically 
  388. # improved by scanning for the name alone first, rather than running 
  389. # complicated regexp search on the entire file.
  390. #
  391. proc fortFindSub {name} {
  392.     set pat1 {^[^cC*!][ ¥ta-z*0-9]*(subroutine|.*function|entry)[ ¥t]+}
  393.     set pos 0
  394.     while {![catch {search -s -f 1 -r 0 -m 0 -i 1 $name $pos} mtch]} {
  395.         set beg [lineStart [lindex $mtch 0]]
  396.         set end [expr [nextLineStart [lindex $mtch 1]] -1]
  397.         set line [getText $beg $end]
  398.         if {[regexp  -nocase $pat1$name $line allofit subtyp name]} {
  399.             return $mtch 
  400.         } else {
  401.             set pos [lindex $mtch 1]
  402.         }
  403.     }
  404.     error "Subroutine ¥"$name¥" not found"
  405. }
  406.  
  407. #=============================================================================
  408. # Fortan auto-indentation
  409. #
  410. # Logic:
  411. #    0.    Identify previous line
  412. #            a) ignore comments and continuation lines
  413. #            b) if current line is a CONTINUE that matches a DO, use the
  414. #                first corresponding DO as the previous line
  415. #
  416. #    1.    Find leading whitespace for previous line
  417. #
  418. #    2.    Increase whitespace if previous line starts a block, i.e.,
  419. #            a) DO loop
  420. #            b) IF ... THEN 
  421. #            c) ELSE
  422. #
  423. #    3.    Decrease whitespace if current line ends a block, i.e.,
  424. #            a) ELSE || ENDIF || END IF || ENDDO || END DO
  425. #            b) <linenum> CONTINUE matching a preceding DO
  426. #
  427. #        or if previous line ends a DO loop on an executable statement, i.e.,
  428. #            c) <linenum> (not CONTINUE) matching a preceding DO
  429. #
  430. ####################################################################################
  431. # Fortan auto-indentation
  432. #
  433. proc FortindentLine {} {    
  434.     set bol [lineStart [getPos]]
  435.     set eol [expr [nextLineStart $bol] - 1]
  436.     Fortindent $bol $eol
  437. }
  438.  
  439. proc FortindentRegion {} {    
  440.     Fortindent [getPos] [selEnd]
  441. }
  442.  
  443. ####################################################################################
  444. # Fortan auto-indentation of a specified region
  445. #
  446. proc Fortindent {pos0 pos1} {
  447.     global fortDooz fortPrevLine fortTop msg
  448.     global FortmodeVars
  449.  
  450.     set tag [quoteExpr2 $FortmodeVars(markTag)]
  451.     set doComment $FortmodeVars(indentComment)
  452.  
  453.     # Define regexps
  454.     set subPat {^[^cC*!][ ¥ta-z*0-9]*(subroutine|.*function|entry|program)[ ¥t]+([a-z0-9_]+)}
  455.     set bolPat {^[^cC*!¥n¥r][ ¥t]*[^ ¥t¥n¥r][^¥r¥n]*$}
  456.     set mtPat {^[ ¥t]*$}
  457.     set tab "    "
  458.     
  459.     set contPat {^     ([^ ¥t¥n¥r])[^¥r¥n]*$}
  460.     set lnumPat {^([ ¥t]*)([0-9]*)([ ¥t]*)(.*)$}
  461.     set comPat "^(¥[cC*!¥]+(${tag})?)(¥[ ¥t¥]*)(.*)¥$"
  462.     set doPat {^[^cC*!¥n¥r][ ¥t]*do[ ¥t]+}
  463.     set tailPat {[^¥r¥n]*$}
  464.     
  465.     set bobPat {^(if[^¥n¥r]*then|else|do)}
  466.     set eobPat {^(end[ ¥t]*if|end[ ¥t]*do|else)}
  467.     set enddoPat {^(end[ ¥t]*do|continue)}
  468.     
  469. #     set fortTop [fortSubTop $pos0]
  470.     set fortTop -1
  471.     
  472.     catch {unset fortDooz}
  473.     set fortPrevLine ""
  474.     
  475.     # Loop over region line by line
  476.     set from [lindex [posToRowCol $pos0] 0]
  477.     set to [lindex [posToRowCol $pos1] 0]
  478.     
  479.     while {$from <= $to} {        
  480.         set msg "Indenting line $from"
  481.         message $msg
  482.         set bol [lineStart [rowColToPos $from 0]]
  483.         set eol [expr [nextLineStart $bol] - 1]
  484.         set thisLine [getText $bol $eol]
  485.         goto $bol
  486.         
  487.         # Check whether we're entering a new routine
  488.         #
  489.         if {[regexp $subPat $thisLine allofit subType subName]} {
  490.             # alertnote "entering subr: ¥/$subName¥/"
  491.             set fortTop $bol
  492.             catch {unset fortDooz}
  493.         } 
  494.         
  495.         # Is the current line a comment line...
  496.         #        
  497.         if {[regexp $comPat $thisLine allofit cc tag pre body]} {
  498.             if {$FortmodeVars(indentComment) > 0} {
  499.                 set body [string trimright $body]
  500.                 # alertnote "comment line: ¥/$pre¥/$body¥/"
  501.                 set lwhite "$cc     "
  502.                 
  503.                 replaceText $bol $eol $lwhite$body
  504.             }
  505.             
  506.         # ... or a line of code (possibly empty)?
  507.         #    
  508.         } elseif {[regexp $lnumPat $thisLine allofit pre lnum post body]} {
  509.             set body [string trimright $body]
  510.             # alertnote "line: ¥/$pre¥/$lnum¥/$post¥/$body¥/"
  511.             
  512.             # is it a continuation line?
  513.             #
  514.             if {(![regexp {¥t} $pre]) && ([string length $pre] == 5)} {
  515.                 set cont [string index $lnum$post$body 0]
  516.                 set body [string trimleft [string range $lnum$post$body 1 end]]
  517.             } else {
  518.                 set cont {}
  519.             }
  520.             # alertnote "cont: ¥/$cont¥/"
  521.             
  522.             # get whitespace for preceding line
  523.             set enddo [getFortPrev $bol $lnum]
  524.             set lwhite [getFortLwhite $bol]
  525.             
  526.             # if this line ends a block, decrease the whitespace
  527.             if {[regexp $eobPat $body] || ($enddo && [regexp -nocase $enddoPat $body])} {
  528.                 set lwlen [expr [string length $lwhite] - 4]
  529.                 set lwhite [string range $lwhite 0 $lwlen]
  530.             } 
  531.             
  532.             if {[string length $lnum]} {
  533.                 if {[string index $lwhite 0] != $tab} {
  534.                     set lwhite [string range $lwhite [expr [string length $lnum] +1] end]
  535.                 }
  536.                 set lnum " $lnum"
  537.             }
  538.             # alertnote "lwhite: ¥/$lwhite¥/ len: [string length $lwhite]"
  539.             # message "$msg : replacing text      "
  540.             
  541.             if {[string length $cont]} {
  542.                 replaceText $bol $eol "     $cont$lwhite$body"    
  543.             } else {
  544.                 replaceText $bol $eol $lnum$lwhite$body
  545.                 if {[string length $body] > 0} {
  546.                     set fortPrevLine $lnum$lwhite$body
  547.                 }
  548.             }
  549.         } else {
  550.             # message "$msg : Couldn't parse line         "
  551.         }
  552.         
  553.         # message "$msg : Done                "
  554.         incr from
  555.     }
  556. }
  557.  
  558. proc getFortLwhite {bol} {
  559.     global fortDooz fortPrevLine fortTop msg
  560.     # Define regexps
  561.     set tab "    "
  562.     set lnumPat {^([ ¥t]*)([0-9]*)([ ¥t]*)(.*)$}
  563.     set doPat {^[^cC*!¥n¥r][ ¥t]*do[ ¥t]+}
  564.     set bobPat {^(if[^¥n¥r]*then|else|do)}
  565.     set enddoPat {^(end[ ¥t]*do|continue)}
  566.     
  567.     if {[regexp $lnumPat $fortPrevLine allofit pre0 lnum0 post0 body0]} {
  568.         # alertnote "prevLine: ¥/$pre0¥/$lnum0¥/$post0¥/$body0¥/"
  569.         
  570.         if {[string length $lnum0]} {
  571.             if {[string index $post0 0] == $tab} {
  572.                 set lwhite $post0
  573.             } else {
  574.                 regsub -all {[0-9]} $pre0$lnum0$post0 { } lwhite
  575.             }
  576.         } else {
  577.             set lwhite $pre0
  578.         }
  579.         # alertnote "lwhite: ¥/$lwhite¥/ len: [string length $lwhite]"
  580.         # message "$msg : got lwhite (initial)"
  581.         
  582.         # if there's a line number and it's not a CONTINUE or ENDDO, 
  583.         # then check for a matching DO statement and adjust 
  584.         # indentation if found
  585.         #
  586.         if {[string length $lnum0] && ![regexp -nocase $enddoPat $body0]} {
  587.             if {[getFortPrev [lineStart [expr $bol - 1]] $lnum0]} {
  588.                 set lwlen [expr [string length $lwhite] - 4]
  589.                 set lwhite [string range $lwhite 0 $lwlen]
  590.  
  591.             }
  592.         }
  593.         
  594.         # If the preceeding line begins a block (IF-THEN, DO, or ELSE),
  595.         # then increase the whitespace
  596.         #    
  597.         if {[regexp -nocase $bobPat $body0]} {
  598.             set lwhite "$lwhite   "
  599.             
  600.             if {[regexp -nocase "$doPat¥(¥[0-9¥]+¥)" $body0 mtch donum]} {
  601.                 set eol [expr [nextLineStart $bol] - 1]
  602.                 set fortDooz($donum) [getText $bol $eol]
  603.             }
  604.         }
  605.         # message "$msg : got lwhite (final)  "
  606.     }
  607.     return "$lwhite"
  608. }
  609.  
  610. proc getFortPrev {bol lnum} {        
  611.     global fortDooz fortPrevLine fortTop msg
  612.     # Define regexps
  613.     set doPat {^[^cC*!¥n¥r][ ¥t]*do[ ¥t]+}
  614.     set bolPat {^[^cC*!¥n¥r][ ¥t]*[^ ¥t¥n¥r][^¥r¥n]*$}
  615.     set contPat {^     ([^ ¥t¥n¥r])[^¥r¥n]*$}
  616.  
  617.     # if there's a line number, check for a matching DO statement ...
  618.     if {[string length $lnum]} {
  619.         if {[lsearch [array names fortDooz] $lnum] >= 0} {
  620.             set fortPrevLine $fortDooz($lnum)
  621.             return 1
  622.         } else {
  623.             if {$fortTop < 0} {
  624.                 set fortTop [fortSubTop $bol]
  625.             }
  626.             if {![catch {search -s -f 0 -r 1 -i 1 -l $fortTop $doPat$lnum [expr $bol -1]} dolst]} {
  627.                 set fortPrevLine [eval getText $dolst]
  628.                 set fortDooz($lnum) $fortPrevLine
  629.                 # alertnote "doLine0: ¥/$fortPrevLine¥/"
  630.                 return 1
  631.             }
  632.         }
  633.     }
  634.         
  635.     # ... otherwise find the first preceding non-comment, non-continuation line
  636.     if {[string length $fortPrevLine] == 0} {
  637.         if {[catch {
  638.             set lst [search -s -f 0 -r 1 -i 1 -s $bolPat [expr $bol-1]]
  639.             set fortPrevLine [eval getText $lst]
  640.             while {[regexp -nocase $contPat $fortPrevLine]} {
  641.                 set lst [search -s -f 0 -r 1 -i 1 $bolPat [expr [lindex $lst 0] - 1]]
  642.                 set fortPrevLine [eval getText $lst]
  643.             }
  644.         }]} {
  645.             # if search fails, we're at the top of a file, so reset indentation
  646.             set fortPrevLine "      continue"
  647.         }
  648.     }
  649.     
  650.     # alertnote "prevLine: ¥/$fortPrevLine¥/"
  651.     # message "$msg : got prevLine"
  652.     return 0
  653. }
  654.  
  655. # Find the beginning of the current subroutine
  656. #
  657. proc fortSubTop {{pos 0}} {
  658.     if {$pos == 0} {
  659.         set pos [lineStart [getPos]]
  660.     }
  661.     set subPat {^[^cC*!][ ¥ta-z*0-9]*(subroutine|.*function|entry|program)[ ¥t]+([a-z0-9_]+)}
  662.     
  663.     if {![catch {search -s -f 0 -r 1 -m 0 -i 1 $subPat $pos} sublst]} {
  664.         # set subLine [eval getText $sublst]
  665.         # alertnote "subLine: ¥/$subLine¥/"
  666.         return [lindex $sublst 0]
  667.     } else {
  668.         return 0
  669.     } 
  670. }